Aminet 1/Aminet - June 1993 [Walnut Creek].iso/usenet/sources/volume90/aplictns/xscheme2/part02

Internet Message Format | 1990-04-14 | 50.1 KB

Path: xanth!cs.odu.edu!Amiga-Request
From: [e-mail] (Amiga Sources/Binaries Moderator)
Newsgroups: comp.sources.amiga
Subject: v90i140: XScheme 0.20 - an object-oriented scheme, Part02/07
Message-ID: <[e-mail]>
Date: 14 Apr 90 21:09:16 GMT
Sender: [e-mail]
Reply-To: [e-mail] (Rusty Haddock)
Lines: 2118
Approved: [e-mail] (Tad Guy)
X-Mail-Submissions-To: [e-mail]
X-Post-Discussions-To: comp.sys.amiga

Submitted-by: [e-mail] (Rusty Haddock)
Posting-number: Volume 90, Issue 140
Archive-name: applications/xscheme-0.20/part02

#!/bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#        "End of archive 2 (of 7)."
# Contents:  Src/msstuff.c Src/xsimage.c Src/xsint.c Src/xsobj.c
#   Src/xsread.c
# Wrapped by tadguy@xanth on Sat Apr 14 17:07:22 1990
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'Src/msstuff.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'Src/msstuff.c'\"
else
echo shar: Extracting \"'Src/msstuff.c'\" \(8253 characters\)
sed "s/^X//" >'Src/msstuff.c' <<'END_OF_FILE'
X/* msstuff.c - ms-dos specific routines */
X
X#include <dos.h>
X#include "xscheme.h"
X
X#define LBSIZE 200
X
X/* external variables */
Xextern LVAL s_unbound,true;
Xextern FILE *tfp;
Xextern int errno;
X
X/* local variables */
Xstatic char lbuf[LBSIZE];
Xstatic int lpos[LBSIZE];
Xstatic int lindex;
Xstatic int lcount;
Xstatic int lposition;
Xstatic long rseed = 1L;
X
X/* osinit - initialize */
Xosinit(banner)
X  char *banner;
X{
X    printf("%s\n",banner);
X    lposition = 0;
X    lindex = 0;
X    lcount = 0;
X}
X
X/* osfinish - clean up before returning to the operating system */
Xosfinish()
X{
X}
X
X/* oserror - print an error message */
Xoserror(msg)
X  char *msg;
X{
X    printf("error: %s\n",msg);
X}
X
X/* osrand - return a random number between 0 and n-1 */
Xint osrand(n)
X  int n;
X{
X    long k1;
X
X    /* make sure we don't get stuck at zero */
X    if (rseed == 0L) rseed = 1L;
X
X    /* algorithm taken from Dr. Dobbs Journal, November 1985, page 91 */
X    k1 = rseed / 127773L;
X    if ((rseed = 16807L * (rseed - k1 * 127773L) - k1 * 2836L) < 0L)
X    rseed += 2147483647L;
X
X    /* return a random number between 0 and n-1 */
X    return ((int)(rseed % (long)n));
X}
X
X/* osaopen - open an ascii file */
XFILE *osaopen(name,mode)
X  char *name,*mode;
X{
X    return (fopen(name,mode));
X}
X
X/* osbopen - open a binary file */
XFILE *osbopen(name,mode)
X  char *name,*mode;
X{
X    char bmode[10];
X    strcpy(bmode,mode); strcat(bmode,"b");
X    return (fopen(name,bmode));
X}
X
X/* osclose - close a file */
Xint osclose(fp)
X  FILE *fp;
X{
X    return (fclose(fp));
X}
X
X/* ostell - get the current file position */
Xlong ostell(fp)
X  FILE *fp;
X{
X    return (ftell(fp));
X}
X
X/* osseek - set the current file position */
Xint osseek(fp,offset,whence)
X  FILE *fp; long offset; int whence;
X{
X    return (fseek(fp,offset,whence));
X}
X
X/* osagetc - get a character from an ascii file */
Xint osagetc(fp)
X  FILE *fp;
X{
X    return (getc(fp));
X}
X
X/* osaputc - put a character to an ascii file */
Xint osaputc(ch,fp)
X  int ch; FILE *fp;
X{
X    return (putc(ch,fp));
X}
X
X/* osbgetc - get a character from a binary file */
Xint osbgetc(fp)
X  FILE *fp;
X{
X    return (getc(fp));
X}
X
X/* osbputc - put a character to a binary file */
Xint osbputc(ch,fp)
X  int ch; FILE *fp;
X{
X    return (putc(ch,fp));
X}
X
X/* ostgetc - get a character from the terminal */
Xint ostgetc()
X{
X    int ch;
X
X    /* check for a buffered character */
X    if (lcount--)
X    return (lbuf[lindex++]);
X
X    /* get an input line */
X    for (lcount = 0; ; )
X    switch (ch = xgetc()) {
X    case '\r':
X        lbuf[lcount++] = '\n';
X        xputc('\r'); xputc('\n'); lposition = 0;
X        if (tfp)
X            for (lindex = 0; lindex < lcount; ++lindex)
X            osaputc(lbuf[lindex],tfp);
X        lindex = 0; lcount--;
X        return (lbuf[lindex++]);
X    case '\010':
X    case '\177':
X        if (lcount) {
X            lcount--;
X            while (lposition > lpos[lcount]) {
X            xputc('\010'); xputc(' '); xputc('\010');
X            lposition--;
X            }
X        }
X        break;
X    case '\032':
X        xflush();
X        return (EOF);
X    default:
X        if (ch == '\t' || (ch >= 0x20 && ch < 0x7F)) {
X            lbuf[lcount] = ch;
X            lpos[lcount] = lposition;
X            if (ch == '\t')
X            do {
X                xputc(' ');
X            } while (++lposition & 7);
X            else {
X            xputc(ch); lposition++;
X            }
X            lcount++;
X        }
X        else {
X            xflush();
X            switch (ch) {
X            case '\003':    xltoplevel();    /* control-c */
X            case '\007':    xlcleanup();    /* control-g */
X            case '\020':    xlcontinue();    /* control-p */
X            case '\032':    return (EOF);    /* control-z */
X            default:        return (ch);
X            }
X        }
X    }
X}
X
X/* ostputc - put a character to the terminal */
Xostputc(ch)
X  int ch;
X{
X    /* check for control characters */
X    oscheck();
X
X    /* output the character */
X    if (ch == '\n') {
X    xputc('\r'); xputc('\n');
X    lposition = 0;
X    }
X    else {
X    xputc(ch);
X    lposition++;
X   }
X
X   /* output the character to the transcript file */
X   if (tfp)
X    osaputc(ch,tfp);
X}
X
X/* osflush - flush the terminal input buffer */
Xosflush()
X{
X    lindex = lcount = lposition = 0;
X}
X
X/* oscheck - check for control characters during execution */
Xoscheck()
X{
X    int ch;
X    if (ch = xcheck())
X    switch (ch) {
X    case '\002':    /* control-b */
X        xflush();
X        xlbreak("BREAK",s_unbound);
X        break;
X    case '\003':    /* control-c */
X        xflush();
X        xltoplevel();
X        break;
X    case '\024':    /* control-t */
X        xinfo();
X        break;
X    case '\023':    /* control-s */
X        while (xcheck() != '\021')
X        ;
X        break;
X    }
X}
X
X/* xinfo - show information on control-t */
Xstatic xinfo()
X{
X/*
X    extern int nfree,gccalls;
X    extern long total;
X    char buf[80];
X    sprintf(buf,"\n[ Free: %d, GC calls: %d, Total: %ld ]",
X        nfree,gccalls,total);
X    errputstr(buf);
X*/
X}
X
X/* xflush - flush the input line buffer and start a new line */
Xstatic xflush()
X{
X    osflush();
X    ostputc('\n');
X}
X
X/* xgetc - get a character from the terminal without echo */
Xstatic int xgetc()
X{
X    return (bdos(7,0,0) & 0xFF);
X}
X
X/* xputc - put a character to the terminal */
Xstatic xputc(ch)
X  int ch;
X{
X    bdos(6,ch,0);
X}
X
X/* xcheck - check for a character */
Xstatic int xcheck()
X{
X    return (bdos(6,0xFF,0) & 0xFF);
X}
X
X/* xinbyte - read a byte from an input port */
XLVAL xinbyte()
X{
X    int portno;
X    LVAL val;
X    val = xlgafixnum(); portno = (int)getfixnum(val);
X    xllastarg();
X    return (cvfixnum((FIXTYPE)inp(portno)));
X}
X
X/* xoutbyte - write a byte to an output port */
XLVAL xoutbyte()
X{
X    int portno,byte;
X    LVAL val;
X    val = xlgafixnum(); portno = (int)getfixnum(val);
X    val = xlgafixnum(); byte = (int)getfixnum(val);
X    xllastarg();
X    outp(portno,byte);
X    return (NIL);
X}
X
X/* xint86 - invoke a system interrupt */
XLVAL xint86()
X{
X    union REGS inregs,outregs;
X    struct SREGS sregs;
X    LVAL inv,outv,val;
X    int intno;
X
X    /* get the interrupt number and the list of register values */
X    val = xlgafixnum(); intno = (int)getfixnum(val);
X    inv = xlgavector();
X    outv = xlgavector();
X    xllastarg();
X
X    /* check the vector lengths */
X    if (getsize(inv) != 9)
X        xlerror("incorrect vector length",inv);
X    if (getsize(outv) != 9)
X    xlerror("incorrect vector length",outv);
X
X    /* load each register from the input vector */
X    val = getelement(inv,0);
X    inregs.x.ax = (fixp(val) ? (int)getfixnum(val) : 0);
X    val = getelement(inv,1);
X    inregs.x.bx = (fixp(val) ? (int)getfixnum(val) : 0);
X    val = getelement(inv,2);
X    inregs.x.cx = (fixp(val) ? (int)getfixnum(val) : 0);
X    val = getelement(inv,3);
X    inregs.x.dx = (fixp(val) ? (int)getfixnum(val) : 0);
X    val = getelement(inv,4);
X    inregs.x.si = (fixp(val) ? (int)getfixnum(val) : 0);
X    val = getelement(inv,5);
X    inregs.x.di = (fixp(val) ? (int)getfixnum(val) : 0);
X    val = getelement(inv,6);
X    sregs.es = (fixp(val) ? (int)getfixnum(val) : 0);
X    val = getelement(inv,7);
X    sregs.ds = (fixp(val) ? (int)getfixnum(val) : 0);
X    val = getelement(inv,8);
X    inregs.x.cflag = (fixp(val) ? (int)getfixnum(val) : 0);
X
X    /* do the system interrupt */
X    int86x(intno,&inregs,&outregs,&sregs);
X
X    /* store the results in the output vector */
X    setelement(outv,0,cvfixnum((FIXTYPE)outregs.x.ax));
X    setelement(outv,1,cvfixnum((FIXTYPE)outregs.x.bx));
X    setelement(outv,2,cvfixnum((FIXTYPE)outregs.x.cx));
X    setelement(outv,3,cvfixnum((FIXTYPE)outregs.x.dx));
X    setelement(outv,4,cvfixnum((FIXTYPE)outregs.x.si));
X    setelement(outv,5,cvfixnum((FIXTYPE)outregs.x.di));
X    setelement(outv,6,cvfixnum((FIXTYPE)sregs.es));
X    setelement(outv,7,cvfixnum((FIXTYPE)sregs.ds));
X    setelement(outv,8,cvfixnum((FIXTYPE)outregs.x.cflag));
X
X    /* return the result list */
X    return (outv);
X}
X
X/* getnext - get the next fixnum from a list */
Xstatic int getnext(plist)
X  LVAL *plist;
X{
X    LVAL val;
X    if (consp(*plist)) {
X        val = car(*plist);
X    *plist = cdr(*plist);
X    if (!fixp(val))
X        xlerror("expecting an integer",val);
X        return ((int)getfixnum(val));
X    }
X    return (0);
X}
X
X/* xsystem - execute a system command */
XLVAL xsystem()
X{
X    char *cmd="COMMAND";
X    if (moreargs())
X    cmd = (char *)getstring(xlgastring());
X    xllastarg();
X    return (system(cmd) == 0 ? true : cvfixnum((FIXTYPE)errno));
X}
X
X/* xgetkey - get a key from the keyboard */
XLVAL xgetkey()
X{
X    xllastarg();
X    return (cvfixnum((FIXTYPE)xgetc()));
X}
X
X/* ossymbols - enter os specific symbols */
Xossymbols()
X{
X}
END_OF_FILE
if test 8253 -ne `wc -c <'Src/msstuff.c'`; then
    echo shar: \"'Src/msstuff.c'\" unpacked with wrong size!
fi
# end of 'Src/msstuff.c'
fi
if test -f 'Src/xsimage.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'Src/xsimage.c'\"
else
echo shar: Extracting \"'Src/xsimage.c'\" \(8825 characters\)
sed "s/^X//" >'Src/xsimage.c' <<'END_OF_FILE'
X/* xsimage.c - xscheme memory image save/restore functions */
X/*    Copyright (c) 1988, by David Michael Betz
X    All Rights Reserved
X    Permission is granted for unrestricted non-commercial use    */
X
X#include "xscheme.h"
X
X/* virtual machine registers */
Xextern LVAL xlfun;        /* current function */
Xextern LVAL xlenv;        /* current environment */
Xextern LVAL xlval;        /* value of most recent instruction */
X
X/* stack limits */
Xextern LVAL *xlstkbase;        /* base of value stack */
Xextern LVAL *xlstktop;        /* top of value stack */
X
X/* node space */
Xextern NSEGMENT *nsegments;    /* list of node segments */
X
X/* vector (and string) space */
Xextern VSEGMENT *vsegments;    /* list of vector segments */
Xextern LVAL *vfree;        /* next free location in vector space */
Xextern LVAL *vtop;        /* top of vector space */
X
X/* global variables */
Xextern LVAL obarray,eof_object,default_object;
Xextern jmp_buf top_level;
Xextern FUNDEF funtab[];
X
X/* local variables */
Xstatic OFFTYPE off,foff;
Xstatic FILE *fp;
X
X/* external routines */
Xextern FILE *osbopen();
X
X/* forward declarations */
XOFFTYPE readptr();
XOFFTYPE cvoptr();
XLVAL cviptr();
X
X/* xlisave - save the memory image */
Xint xlisave(fname)
X  char *fname;
X{
X    unsigned char *cp;
X    NSEGMENT *nseg;
X    int size,n;
X    LVAL p,*vp;
X
X    /* open the output file */
X    if ((fp = osbopen(fname,"w")) == NULL)
X    return (FALSE);
X
X    /* first call the garbage collector to clean up memory */
X    gc();
X
X    /* write out the stack size */
X    writeptr((OFFTYPE)(xlstktop-xlstkbase));
X
X    /* write out the *obarray* symbol and various constants */
X    writeptr(cvoptr(obarray));
X    writeptr(cvoptr(eof_object));
X    writeptr(cvoptr(default_object));
X
X    /* setup the initial file offsets */
X    off = foff = (OFFTYPE)2;
X
X    /* write out all nodes that are still in use */
X    for (nseg = nsegments; nseg != NULL; nseg = nseg->ns_next) {
X    p = &nseg->ns_data[0];
X    n = nseg->ns_size;
X    for (; --n >= 0; ++p, off += sizeof(NODE))
X        switch (ntype(p)) {
X        case FREE:
X        break;
X        case CONS:
X        case CLOSURE:
X        case METHOD:
X        case PROMISE:
X        case ENV:
X        setoffset();
X        osbputc(p->n_type,fp);
X        writeptr(cvoptr(car(p)));
X        writeptr(cvoptr(cdr(p)));
X        foff += sizeof(NODE);
X        break;
X        case SYMBOL:
X        case OBJECT:
X        case VECTOR:
X        case CODE:
X        case CONTINUATION:
X        setoffset();
X        osbputc(p->n_type,fp);
X        size = getsize(p);
X        writeptr((OFFTYPE)size);
X        for (vp = p->n_vdata; --size >= 0; )
X            writeptr(cvoptr(*vp++));
X        foff += sizeof(NODE);
X        break;
X        case STRING:
X        setoffset();
X        osbputc(p->n_type,fp);
X        size = getslength(p);
X        writeptr((OFFTYPE)size);
X        for (cp = getstring(p); --size >= 0; )
X            osbputc(*cp++,fp);
X        foff += sizeof(NODE);
X        break;
X        default:
X        setoffset();
X        writenode(p);
X        foff += sizeof(NODE);
X        break;
X        }
X    }
X
X    /* write the terminator */
X    osbputc(FREE,fp);
X    writeptr((OFFTYPE)0);
X
X    /* close the output file */
X    osclose(fp);
X
X    /* return successfully */
X    return (TRUE);
X}
X
X/* xlirestore - restore a saved memory image */
Xint xlirestore(fname)
X  char *fname;
X{
X    LVAL *getvspace();
X    unsigned int ssize;
X    unsigned char *cp;
X    int size,type;
X    LVAL p,*vp;
X
X    /* open the file */
X    if ((fp = osbopen(fname,"r")) == NULL)
X    return (FALSE);
X
X    /* free the old memory image */
X    freeimage();
X
X    /* read the stack size */
X    ssize = (unsigned int)readptr();
X
X    /* allocate memory for the workspace */
X    xlminit(ssize);
X
X    /* read the *obarray* symbol and various constants */
X    obarray = cviptr(readptr());
X    eof_object = cviptr(readptr());
X    default_object = cviptr(readptr());
X
X    /* read each node */
X    for (off = (OFFTYPE)2; (type = osbgetc(fp)) >= 0; )
X    switch (type) {
X    case FREE:
X        if ((off = readptr()) == (OFFTYPE)0)
X        goto done;
X        break;
X    case CONS:
X    case CLOSURE:
X    case METHOD:
X    case PROMISE:
X    case ENV:
X        p = cviptr(off);
X        p->n_type = type;
X        rplaca(p,cviptr(readptr()));
X        rplacd(p,cviptr(readptr()));
X        off += sizeof(NODE);
X        break;
X    case SYMBOL:
X    case OBJECT:
X    case VECTOR:
X    case CODE:
X    case CONTINUATION:
X        p = cviptr(off);
X        p->n_type = type;
X        p->n_vsize = size = (int)readptr();
X        p->n_vdata = getvspace(p,size);
X        for (vp = p->n_vdata; --size >= 0; )
X        *vp++ = cviptr(readptr());
X        off += sizeof(NODE);
X        break;
X    case STRING:
X        p = cviptr(off);
X        p->n_type = type;
X        p->n_vsize = size = (int)readptr();
X        p->n_vdata = getvspace(p,btow_size(size));
X        for (cp = getstring(p); --size >= 0; )
X        *cp++ = osbgetc(fp);
X        off += sizeof(NODE);
X        break;
X    case PORT:
X        p = cviptr(off);
X        readnode(type,p);
X        setfile(p,NULL);
X        off += sizeof(NODE);
X        break;
X    case SUBR:
X    case XSUBR:
X        p = cviptr(off);
X        readnode(type,p);
X        p->n_subr = funtab[getoffset(p)].fd_subr;
X        off += sizeof(NODE);
X        break;
X    default:
X        readnode(type,cviptr(off));
X        off += sizeof(NODE);
X        break;
X    }
Xdone:
X
X    /* close the input file */
X    osclose(fp);
X
X    /* collect to initialize the free space */
X    gc();
X
X    /* lookup all of the symbols the interpreter uses */
X    xlsymbols();
X
X    /* return successfully */
X    return (TRUE);
X}
X
X/* freeimage - free the current memory image */
XLOCAL freeimage()
X{
X    NSEGMENT *nextnseg;
X    VSEGMENT *nextvseg;
X    FILE *fp;
X    LVAL p;
X    int n;
X
X    /* close all open ports and free each node segment */
X    for (; nsegments != NULL; nsegments = nextnseg) {
X    nextnseg = nsegments->ns_next;
X    p = &nsegments->ns_data[0];
X    n = nsegments->ns_size;
X    for (; --n >= 0; ++p)
X        switch (ntype(p)) {
X        case PORT:
X        if ((fp = getfile(p))
X         && (fp != stdin && fp != stdout && fp != stderr))
X            osclose(getfile(p));
X        break;
X        }
X    free(nsegments);
X    }
X
X    /* free each vector segment */
X    for (; vsegments != NULL; vsegments = nextvseg) {
X    nextvseg = vsegments->vs_next;
X    free(vsegments);
X    }
X
X    /* free the stack */
X    if (xlstkbase)
X    free(xlstkbase);
X}
X
X/* setoffset - output a positioning command if nodes have been skipped */
XLOCAL setoffset()
X{
X    if (off != foff) {
X    osbputc(FREE,fp);
X    writeptr(off);
X    foff = off;
X    }
X}
X
X/* writenode - write a node to a file */
XLOCAL writenode(node)
X  LVAL node;
X{
X    char *p = (char *)&node->n_info;
X    int n = sizeof(union ninfo);
X    osbputc(node->n_type,fp);
X    while (--n >= 0)
X    osbputc(*p++,fp);
X}
X
X/* writeptr - write a pointer to a file */
XLOCAL writeptr(off)
X  OFFTYPE off;
X{
X    char *p = (char *)&off;
X    int n = sizeof(OFFTYPE);
X    while (--n >= 0)
X    osbputc(*p++,fp);
X}
X
X/* readnode - read a node */
XLOCAL readnode(type,node)
X  int type; LVAL node;
X{
X    char *p = (char *)&node->n_info;
X    int n = sizeof(union ninfo);
X    node->n_type = type;
X    while (--n >= 0)
X    *p++ = osbgetc(fp);
X}
X
X/* readptr - read a pointer */
XLOCAL OFFTYPE readptr()
X{
X    OFFTYPE off;
X    char *p = (char *)&off;
X    int n = sizeof(OFFTYPE);
X    while (--n >= 0)
X    *p++ = osbgetc(fp);
X    return (off);
X}
X
X/* cviptr - convert a pointer on input */
XLOCAL LVAL cviptr(o)
X  OFFTYPE o;
X{
X    NSEGMENT *newnsegment(),*nseg;
X    OFFTYPE off = (OFFTYPE)2;
X    OFFTYPE nextoff;
X
X    /* check for nil and small fixnums */
X    if (o == (OFFTYPE)0 || (o & 1) == 1)
X    return ((LVAL)o);
X
X    /* compute a pointer for this offset */
X    for (nseg = nsegments; nseg != NULL; nseg = nseg->ns_next) {
X    nextoff = off + (OFFTYPE)(nseg->ns_size * sizeof(NODE));
X    if (o >= off && o < nextoff)
X        return ((LVAL)((OFFTYPE)&nseg->ns_data[0] + o - off));
X    off = nextoff;
X    }
X
X    /* create new segments if necessary */
X    for (;;) {
X
X    /* create the next segment */
X    if ((nseg = newnsegment(NSSIZE)) == NULL)
X        xlfatal("insufficient memory - segment");
X
X    /* check to see if the offset is in this segment */
X    nextoff = off + (OFFTYPE)(nseg->ns_size * sizeof(NODE));
X    if (o >= off && o < nextoff)
X        return ((LVAL)((OFFTYPE)&nseg->ns_data[0] + o - off));
X    off = nextoff;
X    }
X}
X
X/* cvoptr - convert a pointer on output */
XLOCAL OFFTYPE cvoptr(p)
X  LVAL p;
X{
X    OFFTYPE off = (OFFTYPE)2;
X    NSEGMENT *nseg;
X
X    /* check for nil and small fixnums */
X    if (p == NIL || !ispointer(p))
X    return ((OFFTYPE)p);
X
X    /* compute an offset for this pointer */
X    for (nseg = nsegments; nseg != NULL; nseg = nseg->ns_next) {
X    if (INSEGMENT(p,nseg))
X        return (off + ((OFFTYPE)p - (OFFTYPE)&nseg->ns_data[0]));
X    off += (OFFTYPE)(nseg->ns_size * sizeof(NODE));
X    }
X
X    /* pointer not within any segment */
X    xlerror("bad pointer found during image save",p);
X}
X
X/* getvspace - allocate vector space */
XLOCAL LVAL *getvspace(node,size)
X  LVAL node; unsigned int size;
X{
X    LVAL *p;
X    ++size; /* space for the back pointer */
X    if (vfree + size >= vtop) {
X    makevmemory(size);
X    if (vfree + size >= vtop)
X        xlfatal("insufficient vector space");
X    }
X    p = vfree;
X    vfree += size;
X    *p++ = node;
X    return (p);
X}
END_OF_FILE
if test 8825 -ne `wc -c <'Src/xsimage.c'`; then
    echo shar: \"'Src/xsimage.c'\" unpacked with wrong size!
fi
# end of 'Src/xsimage.c'
fi
if test -f 'Src/xsint.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'Src/xsint.c'\"
else
echo shar: Extracting \"'Src/xsint.c'\" \(10297 characters\)
sed "s/^X//" >'Src/xsint.c' <<'END_OF_FILE'
X/* xsint.c - xscheme bytecode interpreter */
X/*    Copyright (c) 1988, by David Michael Betz
X    All Rights Reserved
X    Permission is granted for unrestricted non-commercial use    */
X
X#include "xscheme.h"
X#include "xsbcode.h"
X
X/* sample rate (instructions per sample) */
X#define SRATE    1000
X
X/* macros to get the address of the code string for a code object */
X#define getcodestr(x) ((unsigned char *)getstring(getbcode(x)))
X
X/* globals */
Xint trace=FALSE;    /* trace enable */
Xint xlargc;        /* argument count */
Xjmp_buf bc_dispatch;    /* bytecode dispatcher */
X
X/* external variables */
Xextern LVAL xlfun,xlenv,xlval;
Xextern LVAL s_stdin,s_stdout,s_unbound;
Xextern LVAL s_unassigned,default_object,true;
X
X/* external routines */
Xextern LVAL xadd(),xsub(),xmul(),xdiv(),xlss(),xeql(),xgtr();
X
X/* local variables */
Xstatic unsigned char *base,*pc;
Xstatic int sample=SRATE;
X
X/* xtraceon - built-in function 'trace-on' */
XLVAL xtraceon()
X{
X    xllastarg()
X    trace = TRUE;
X    return (NIL);
X}
X
X/* xtraceoff - built-in function 'trace-off' */
XLVAL xtraceoff()
X{
X    xllastarg()
X    trace = FALSE;
X    return (NIL);
X}
X
X/* xlexecute - execute byte codes */
Xxlexecute(fun)
X  LVAL fun;
X{
X    LVAL findvar(),make_continuation();
X    register LVAL tmp;
X    register unsigned int i;
X    register int k;
X    int off;
X
X    /* initialize the registers */
X    xlfun = getcode(fun);
X    xlenv = getenv(fun);
X    xlval = NIL;
X
X    /* initialize the argument count */
X    xlargc = 0;
X
X    /* set the initial pc */
X    base = pc = getcodestr(xlfun);
X
X    /* setup a target for the error handler */
X    setjmp(bc_dispatch);
X
X    /* execute the code */
X    for (;;) {
X
X    /* check for control codes */
X    if (--sample <= 0) {
X        sample = SRATE;
X        oscheck();
X    }
X
X    /* print the trace information */
X    if (trace)
X        decode_instruction(curoutput(),xlfun,(int)(pc-base),xlenv);
X
X    /* execute the next bytecode instruction */
X    switch (*pc++) {
X    case OP_BRT:
X        i = *pc++ << 8; i |= *pc++;
X        if (xlval) pc = base + i;
X        break;
X    case OP_BRF:
X        i = *pc++ << 8; i |= *pc++;
X        if (!xlval) pc = base + i;
X        break;
X    case OP_BR:
X        i = *pc++ << 8; i |= *pc++;
X        pc = base + i;
X        break;
X    case OP_LIT:
X        xlval = getelement(xlfun,*pc++);
X        break;
X    case OP_GREF:
X        tmp = getelement(xlfun,*pc++);
X        if ((xlval = getvalue(tmp)) == s_unbound) {
X            if (xlval = getvalue(xlenter("*UNBOUND-HANDLER*"))) {
X            oscheck();
X            pc -= 2; /* backup the pc */
X            tmp = make_continuation();
X            check(2);
X            push(tmp);
X            push(getelement(xlfun,pc[1]));
X            xlargc = 2;
X            xlapply();
X            }
X            else
X            xlerror("unbound variable",tmp);
X        }
X        break;
X    case OP_GSET:
X        setvalue(getelement(xlfun,*pc++),xlval);
X        break;
X    case OP_EREF:
X        k = *pc++;
X        tmp = xlenv;
X        while (--k >= 0) tmp = cdr(tmp);
X        xlval = getelement(car(tmp),*pc++);
X        break;
X    case OP_ESET:
X        k = *pc++;
X        tmp = xlenv;
X        while (--k >= 0) tmp = cdr(tmp);
X        setelement(car(tmp),*pc++,xlval);
X        break;
X    case OP_AREF:
X        i = *pc++;
X        tmp = xlval;
X        if (!envp(tmp)) badargtype(tmp);
X        if ((tmp = findvar(tmp,getelement(xlfun,i),&off)) != NIL)
X            xlval = getelement(car(tmp),off);
X        else
X            xlval = s_unassigned;
X        break;
X    case OP_ASET:
X        i = *pc++;
X        tmp = pop();
X        if (!envp(tmp)) badargtype(tmp);
X        if ((tmp = findvar(tmp,getelement(xlfun,i),&off)) == NIL)
X            xlerror("no binding for variable",getelement(xlfun,i));
X        setelement(car(tmp),off,xlval);
X        break;
X    case OP_SAVE:    /* save a continuation */
X        i = *pc++ << 8; i |= *pc++;
X        check(3);
X        push(cvsfixnum((FIXTYPE)i));
X        push(xlfun);
X        push(xlenv);
X        break;
X    case OP_CALL:    /* call a function (or built-in) */
X        xlargc = *pc++;    /* get argument count */
X        xlapply();    /* apply the function */
X        break;
X    case OP_RETURN:    /* return to the continuation on the stack */
X        xlreturn();
X        break;
X    case OP_FRAME:    /* create an environment frame */
X        i = *pc++;    /* get the frame size */
X        xlenv = newframe(xlenv,i);
X        setelement(car(xlenv),0,getvnames(xlfun));
X        break;
X    case OP_MVARG:    /* move required argument to frame slot */
X        i = *pc++;    /* get the slot number */
X        if (--xlargc < 0)
X            xlfail("too few arguments");
X        setelement(car(xlenv),i,pop());
X        break;
X    case OP_MVOARG:    /* move optional argument to frame slot */
X        i = *pc++;    /* get the slot number */
X        if (xlargc > 0) {
X            setelement(car(xlenv),i,pop());
X            --xlargc;
X        }
X        else
X            setelement(car(xlenv),i,default_object);
X        break;
X    case OP_MVRARG:    /* build rest argument and move to frame slot */
X        i = *pc++;    /* get the slot number */
X        for (xlval = NIL, k = xlargc; --k >= 0; )
X            xlval = cons(xlsp[k],xlval);
X        setelement(car(xlenv),i,xlval);
X        drop(xlargc);
X        break;
X    case OP_ALAST:    /* make sure there are no more arguments */
X        if (xlargc > 0)
X            xlfail("too many arguments");
X        break;
X    case OP_T:
X        xlval = true;
X        break;
X    case OP_NIL:
X        xlval = NIL;
X        break;
X    case OP_PUSH:
X        cpush(xlval);
X        break;
X    case OP_CLOSE:
X        if (!codep(xlval)) badargtype(xlval);
X        xlval = cvclosure(xlval,xlenv);
X        break;
X    case OP_DELAY:
X        if (!codep(xlval)) badargtype(xlval);
X        xlval = cvpromise(xlval,xlenv);
X        break;
X    case OP_ATOM:
X        xlval = (atom(xlval) ? true : NIL);
X        break;
X    case OP_EQ:
X        xlval = (xlval == pop() ? true : NIL);
X        break;
X    case OP_NULL:
X        xlval = (xlval ? NIL : true);
X        break;
X    case OP_CONS:
X        xlval = cons(xlval,pop());
X        break;
X    case OP_CAR:
X        if (!listp(xlval)) badargtype(xlval);
X        xlval = (xlval ? car(xlval) : NIL);
X        break;
X    case OP_CDR:
X        if (!listp(xlval)) badargtype(xlval);
X        xlval = (xlval ? cdr(xlval) : NIL);
X        break;
X    case OP_SETCAR:
X        if (!consp(xlval)) badargtype(xlval);
X        rplaca(xlval,pop());
X        break;
X    case OP_SETCDR:
X        if (!consp(xlval)) badargtype(xlval);
X        rplacd(xlval,pop());
X        break;
X    case OP_ADD:
X        tmp = pop();
X        if (fixp(xlval) && fixp(tmp))
X            xlval = cvfixnum(getfixnum(xlval) + getfixnum(tmp));
X        else {
X            push(tmp); push(xlval); xlargc = 2;
X            xlval = xadd();
X        }
X        break;
X    case OP_SUB:
X        tmp = pop();
X        if (fixp(xlval) && fixp(tmp))
X            xlval = cvfixnum(getfixnum(xlval) - getfixnum(tmp));
X        else {
X            push(tmp); push(xlval); xlargc = 2;
X            xlval = xsub();
X        }
X        break;
X    case OP_MUL:
X        tmp = pop();
X        if (fixp(xlval) && fixp(tmp))
X            xlval = cvfixnum(getfixnum(xlval) * getfixnum(tmp));
X        else {
X            push(tmp); push(xlval); xlargc = 2;
X            xlval = xmul();
X        }
X        break;
X    case OP_QUO:
X        tmp = pop();
X        if (fixp(xlval) && fixp(tmp))
X            xlval = cvfixnum(getfixnum(xlval) / getfixnum(tmp));
X        else if (fixp(xlval))
X            badargtype(tmp);
X        else
X            badargtype(xlval);
X        break;
X    case OP_LSS:
X        tmp = pop();
X        if (fixp(xlval) && fixp(tmp))
X            xlval = (getfixnum(xlval) < getfixnum(tmp) ? true : NIL);
X        else {
X            push(tmp); push(xlval); xlargc = 2;
X            xlval = xlss();
X        }
X        break;
X    case OP_EQL:
X        tmp = pop();
X        if (fixp(xlval) && fixp(tmp))
X            xlval = (getfixnum(xlval) == getfixnum(tmp) ? true : NIL);
X        else {
X            push(tmp); push(xlval); xlargc = 2;
X            xlval = xeql();
X        }
X        break;
X    case OP_GTR:
X        tmp = pop();
X        if (fixp(xlval) && fixp(tmp))
X            xlval = (getfixnum(xlval) > getfixnum(tmp) ? true : NIL);
X        else {
X            push(tmp); push(xlval); xlargc = 2;
X            xlval = xgtr();
X        }
X        break;
X    default:
X        xlerror("bad opcode",cvsfixnum((FIXTYPE)*--pc));
X        break;
X    }
X    }
X}
X
X/* findvar - find a variable in an environment */
XLOCAL LVAL findvar(env,var,poff)
X  LVAL env,var; int *poff;
X{
X    LVAL names;
X    int off;
X    for (; env != NIL; env = cdr(env)) {
X    names = getelement(car(env),0);
X    for (off = 1; names != NIL; ++off, names = cdr(names))
X        if (var == car(names)) {
X        *poff = off;
X        return (env);
X        }
X    }
X    return (NIL);
X}
X
X/* xlapply - apply a function to arguments */
X/*    The function should be in xlval and the arguments should
X    be on the stack.  The number of arguments should be in xlargc.
X*/
Xxlapply()
X{
X    LVAL tmp;
X
X    /* check for null function */
X    if (null(xlval))
X    badfuntype(xlval);
X
X    /* dispatch on function type */
X    switch (ntype(xlval)) {
X    case SUBR:
X    xlval = (*getsubr(xlval))();
X    xlreturn();
X    break;
X    case XSUBR:
X    (*getsubr(xlval))();
X    break;
X    case CLOSURE:
X    xlfun = getcode(xlval);
X    xlenv = getenv(xlval);
X    base = pc = getcodestr(xlfun);
X    break;
X    case OBJECT:
X    xlsend(xlval,xlgasymbol());
X    break;
X    case METHOD:
X    xlfun = getcode(xlval);
X    xlenv = cons(top(),getenv(xlval));
X    base = pc = getcodestr(xlfun);
X    break;
X    case CONTINUATION:
X    tmp = xlgetarg();
X    xllastarg();
X    restore_continuation();
X    xlval = tmp;
X    xlreturn();
X    break;
X    default:
X    badfuntype(xlval);
X    }
X}
X
X/* xlreturn - return to a continuation on the stack */
Xxlreturn()
X{
X    LVAL tmp;
X
X    /* restore the enviroment and the continuation function */
X    xlenv = pop();
X    tmp = pop();
X
X    /* dispatch on the function type */
X    switch (ntype(tmp)) {
X    case CODE:
X        xlfun = tmp;
X        tmp = pop();
X    base = getcodestr(xlfun);
X    pc = base + (int)getsfixnum(tmp);
X    break;
X    case CSUBR:
X    (*getsubr(tmp))();
X    break;
X    default:
X    xlerror("bad continuation",tmp);
X    }
X}
X
X/* make_continuation - make a continuation */
XLOCAL LVAL make_continuation()
X{
X    LVAL cont,*src,*dst;
X    int size;
X
X    /* save a continuation on the stack */
X    check(3);
X    push(cvsfixnum((FIXTYPE)(pc - base)));
X    push(xlfun);
X    push(xlenv);
X
X    /* create and initialize a continuation object */
X    size = (int)(xlstktop - xlsp);
X    cont = newcontinuation(size);
X    for (src = xlsp, dst = &cont->n_vdata[0]; --size >= 0; )
X    *dst++ = *src++;
X
X    /* return the continuation */
X    return (cont);
X}
X
X/* restore_continuation - restore a continuation to the stack */
X/*    The continuation should be in xlval.
X*/
XLOCAL restore_continuation()
X{
X    LVAL *src;
X    int size;
X    size = getsize(xlval);
X    for (src = &xlval->n_vdata[size], xlsp = xlstktop; --size >= 0; )
X    *--xlsp = *--src;
X}
X
X/* gc_protect - protect the state of the interpreter from the collector */
Xgc_protect(protected_fcn)
X  int (*protected_fcn)();
X{
X    int pcoff;
X    pcoff = pc - base;
X    (*protected_fcn)();
X    if (xlfun) {
X    base = getcodestr(xlfun);
X    pc = base + pcoff;
X    }
X}
X
X/* badfuntype - bad function error */
XLOCAL badfuntype(arg)
X  LVAL arg;
X{
X    xlerror("bad function type",arg);
X}
X
X/* badargtype - bad argument type error */
XLOCAL badargtype(arg)
X  LVAL arg;
X{
X    xlbadtype(arg);
X}
X
X/* xlstkover - value stack overflow */
Xxlstkover()
X{
X    xlabort("value stack overflow");
X}
END_OF_FILE
if test 10297 -ne `wc -c <'Src/xsint.c'`; then
    echo shar: \"'Src/xsint.c'\" unpacked with wrong size!
fi
# end of 'Src/xsint.c'
fi
if test -f 'Src/xsobj.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'Src/xsobj.c'\"
else
echo shar: Extracting \"'Src/xsobj.c'\" \(9292 characters\)
sed "s/^X//" >'Src/xsobj.c' <<'END_OF_FILE'
X/* xsobj.c - xscheme object-oriented programming support */
X/*    Copyright (c) 1988, by David Michael Betz
X    All Rights Reserved
X    Permission is granted for unrestricted non-commercial use    */
X
X#include "xscheme.h"
X
X/* external variables */
Xextern LVAL xlenv,xlval;
Xextern LVAL s_stdout;
X
X/* local variables */
Xstatic LVAL s_self,k_isnew;
Xstatic LVAL class,object;
X
X/* instance variable numbers for the class 'Class' */
X#define MESSAGES    2    /* list of messages */
X#define IVARS        3    /* list of instance variable names */
X#define CVARS        4    /* env containing class variables */
X#define SUPERCLASS    5    /* pointer to the superclass */
X#define IVARCNT        6    /* number of class instance variables */
X#define IVARTOTAL    7    /* total number of instance variables */
X
X/* number of instance variables for the class 'Class' */
X#define CLASSSIZE    6
X
X/* forward declarations */
XFORWARD LVAL entermsg();
XFORWARD LVAL copylists();
X
X/* xlsend - send a message to an object */
Xxlsend(obj,sym)
X  LVAL obj,sym;
X{
X    LVAL msg,cls,p;
X
X    /* look for the message in the class or superclasses */
X    for (cls = getclass(obj); cls; cls = getivar(cls,SUPERCLASS))
X    for (p = getivar(cls,MESSAGES); p; p = cdr(p))
X        if ((msg = car(p)) && car(msg) == sym) {
X        push(obj); ++xlargc; /* insert 'self' argument */
X        xlval = cdr(msg);    /* get the method */
X        xlapply();         /* invoke the method */
X        return;
X        }
X
X    /* message not found */
X    xlerror("no method for this message",sym);
X}
X
X/* xsendsuper - built-in function 'send-super' */
XLVAL xsendsuper()
X{
X    LVAL obj,sym,msg,cls,p;
X
X    /* get the message selector */
X    sym = xlgasymbol();
X
X    /* find the 'self' object */
X    for (obj = xlenv; obj; obj = cdr(obj))
X    if (ntype(car(obj)) == OBJECT)
X        goto find_method;
X    xlerror("not in a method",sym);
X
Xfind_method:
X    /* get the message class and the 'self' object */
X    cls = getivar(getelement(car(cdr(obj)),0),SUPERCLASS);
X    obj = car(obj);
X
X    /* look for the message in the class or superclasses */
X    for (; cls; cls = getivar(cls,SUPERCLASS))
X    for (p = getivar(cls,MESSAGES); p; p = cdr(p))
X        if ((msg = car(p)) && car(msg) == sym) {
X        push(obj); ++xlargc; /* insert 'self' argument */
X        xlval = cdr(msg);    /* get the method */
X        xlapply();         /* invoke the method */
X        return;
X        }
X
X    /* message not found */
X    xlerror("no method for this message",sym);
X}
X
X/* obisnew - default 'isnew' method */
XLVAL obisnew()
X{
X    LVAL self;
X    self = xlgaobject();
X    xllastarg();
X    return (self);
X}
X
X/* obclass - get the class of an object */
XLVAL obclass()
X{
X    LVAL self;
X    self = xlgaobject();
X    xllastarg();
X    return (getclass(self));
X}
X
X/* obshow - show the instance variables of an object */
XLVAL obshow()
X{
X    LVAL self,fptr,cls,names;
X    int maxi,i;
X
X    /* get self and the file pointer */
X    self = xlgaobject();
X    fptr = (moreargs() ? xlgaoport() : getvalue(s_stdout));
X    xllastarg();
X
X    /* get the object's class */
X    cls = getclass(self);
X
X    /* print the object and class */
X    xlputstr(fptr,"Object is ");
X    xlprin1(self,fptr);
X    xlputstr(fptr,", Class is ");
X    xlprin1(cls,fptr);
X    xlterpri(fptr);
X
X    /* print the object's instance variables */
X    names = cdr(getivar(cls,IVARS));
X    maxi = getivcnt(cls,IVARTOTAL)+1;
X    for (i = 2; i <= maxi; ++i) {
X    xlputstr(fptr,"  ");
X    xlprin1(car(names),fptr);
X    xlputstr(fptr," = ");
X    xlprin1(getivar(self,i),fptr);
X    xlterpri(fptr);
X    names = cdr(names);
X    }
X
X    /* return the object */
X    return (self);
X}
X
X/* clnew - create a new object instance */
XLVAL clnew()
X{
X    LVAL self;
X
X    /* create a new object */
X    self = xlgaobject();
X    xlval = newobject(self,getivcnt(self,IVARTOTAL));
X
X    /* send the 'isnew' message */
X    xlsend(xlval,k_isnew);
X}
X
X/* clisnew - initialize a new class */
XLVAL clisnew()
X{
X    LVAL self,ivars,cvars,super;
X    int n;
X
X    /* get self, the ivars, cvars and superclass */
X    self = xlgaobject();
X    ivars = xlgalist();
X    cvars = (moreargs() ? xlgalist() : NIL);
X    super = (moreargs() ? xlgaobject() : object);
X    xllastarg();
X
X    /* create the class variable name list */
X    cpush(cons(xlenter("%%CLASS"),copylists(cvars,NIL)));
X
X    /* create the class variable environment */
X    xlval = newframe(getivar(super,CVARS),listlength(xlval)+1);
X    setelement(car(xlval),0,pop());
X    setelement(car(xlval),1,self);
X    push(xlval);
X
X    /* store the instance and class variable lists and the superclass */
X    setivar(self,IVARS,copylists(getivar(super,IVARS),ivars));
X    setivar(self,CVARS,pop());
X    setivar(self,SUPERCLASS,super);
X
X    /* compute the instance variable count */
X    n = listlength(ivars);
X    setivar(self,IVARCNT,cvfixnum((FIXTYPE)n));
X    n += getivcnt(super,IVARTOTAL);
X    setivar(self,IVARTOTAL,cvfixnum((FIXTYPE)n));
X
X    /* return the new class object */
X    return (self);
X}
X
X/* clanswer - define a method for answering a message */
XLVAL clanswer()
X{
X    extern LVAL xlfunction();
X    LVAL self,msg,fargs,code,mptr;
X
X    /* message symbol, formal argument list and code */
X    self = xlgaobject();
X    msg = xlgasymbol();
X    fargs = xlgetarg();
X    code = xlgalist();
X    xllastarg();
X
X    /* make a new message list entry */
X    mptr = entermsg(self,msg);
X
X    /* add 'self' to the argument list */
X    cpush(cons(s_self,fargs));
X
X    /* extend the class variable environment with the instance variables */
X    xlval = newframe(getivar(self,CVARS),1);
X    setelement(car(xlval),0,getivar(self,IVARS));
X
X    /* compile and store the method */
X    xlval = xlfunction(msg,top(),code,xlval);
X    rplacd(mptr,cvmethod(xlval,getivar(self,CVARS)));
X    drop(1);
X
X    /* return the object */
X    return (self);
X}
X
X/* addivar - enter an instance variable */
XLOCAL addivar(cls,var)
X  LVAL cls; char *var;
X{
X    setivar(cls,IVARS,cons(xlenter(var),getivar(cls,IVARS)));
X}
X
X/* addmsg - add a message to a class */
XLOCAL addmsg(cls,msg,fname)
X  LVAL cls; char *msg,*fname;
X{
X    LVAL mptr;
X
X    /* enter the message selector */
X    mptr = entermsg(cls,xlenter(msg));
X
X    /* store the method for this message */
X    rplacd(mptr,getvalue(xlenter(fname)));
X}
X
X/* entermsg - add a message to a class */
XLOCAL LVAL entermsg(cls,msg)
X  LVAL cls,msg;
X{
X    LVAL lptr,mptr;
X
X    /* lookup the message */
X    for (lptr = getivar(cls,MESSAGES); lptr; lptr = cdr(lptr))
X    if (car(mptr = car(lptr)) == msg)
X        return (mptr);
X
X    /* allocate a new message entry if one wasn't found */
X    cpush(cons(msg,NIL));
X    setivar(cls,MESSAGES,cons(top(),getivar(cls,MESSAGES)));
X
X    /* return the symbol node */
X    return (pop());
X}
X
X/* getivcnt - get the number of instance variables for a class */
XLOCAL int getivcnt(cls,ivar)
X  LVAL cls; int ivar;
X{
X    LVAL cnt;
X    if ((cnt = getivar(cls,ivar)) == NIL || !fixp(cnt))
X    xlerror("bad value for instance variable count",cnt);
X    return ((int)getfixnum(cnt));
X}
X
X/* copylist - make a copy of a list */
XLOCAL LVAL copylists(list1,list2)
X  LVAL list1,list2;
X{
X    LVAL last,next;
X
X    /* initialize */
X    cpush(NIL); last = NIL;
X
X    /* copy the first list */
X    for (; consp(list1); list1 = cdr(list1)) {
X    next = cons(car(list1),NIL);
X    if (last) rplacd(last,next);
X    else settop(next);
X    last = next;
X    }
X
X    /* append the second list */
X    for (; consp(list2); list2 = cdr(list2)) {
X    next = cons(car(list2),NIL);
X    if (last) rplacd(last,next);
X    else settop(next);
X    last = next;
X    }
X    return (pop());
X}
X
X/* listlength - find the length of a list */
XLOCAL int listlength(list)
X  LVAL list;
X{
X    int len;
X    for (len = 0; consp(list); len++)
X    list = cdr(list);
X    return (len);
X}
X
X/* obsymbols - initialize symbols */
Xobsymbols()
X{
X    /* enter the object related symbols */
X    s_self  = xlenter("SELF");
X    k_isnew = xlenter("ISNEW");
X
X    /* get the Object and Class symbol values */
X    object = getvalue(xlenter("OBJECT"));
X    class  = getvalue(xlenter("CLASS"));
X}
X
X/* xloinit - object function initialization routine */
Xxloinit()
X{
X    LVAL sym;
X
X    /* create the 'Object' object */
X    sym = xlenter("OBJECT");
X    object = newobject(NIL,CLASSSIZE);
X    setvalue(sym,object);
X    setivar(object,IVARS,cons(xlenter("%%CLASS"),NIL));
X    setivar(object,IVARCNT,cvfixnum((FIXTYPE)0));
X    setivar(object,IVARTOTAL,cvfixnum((FIXTYPE)0));
X    addmsg(object,"ISNEW","%OBJECT-ISNEW");
X    addmsg(object,"CLASS","%OBJECT-CLASS");
X    addmsg(object,"SHOW","%OBJECT-SHOW");
X
X    /* create the 'Class' object */
X    sym = xlenter("CLASS");
X    class = newobject(NIL,CLASSSIZE);
X    setvalue(sym,class);
X    addivar(class,"IVARTOTAL");    /* ivar number 6 */
X    addivar(class,"IVARCNT");    /* ivar number 5 */
X    addivar(class,"SUPERCLASS");/* ivar number 4 */
X    addivar(class,"CVARS");    /* ivar number 3 */
X    addivar(class,"IVARS");    /* ivar number 2 */
X    addivar(class,"MESSAGES");    /* ivar number 1 */
X    setivar(class,IVARS,cons(xlenter("%%CLASS"),getivar(class,IVARS)));
X    setivar(class,IVARCNT,cvfixnum((FIXTYPE)CLASSSIZE));
X    setivar(class,IVARTOTAL,cvfixnum((FIXTYPE)CLASSSIZE));
X    setivar(class,SUPERCLASS,object);
X    addmsg(class,"NEW","%CLASS-NEW");
X    addmsg(class,"ISNEW","%CLASS-ISNEW");
X    addmsg(class,"ANSWER","%CLASS-ANSWER");
X
X    /* patch the class into 'object' and 'class' */
X    setclass(object,class);
X    setclass(class,class);
X}
END_OF_FILE
if test 9292 -ne `wc -c <'Src/xsobj.c'`; then
    echo shar: \"'Src/xsobj.c'\" unpacked with wrong size!
fi
# end of 'Src/xsobj.c'
fi
if test -f 'Src/xsread.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'Src/xsread.c'\"
else
echo shar: Extracting \"'Src/xsread.c'\" \(9004 characters\)
sed "s/^X//" >'Src/xsread.c' <<'END_OF_FILE'
X/* xsread.c - xscheme input routines */
X/*    Copyright (c) 1988, by David Michael Betz
X    All Rights Reserved
X    Permission is granted for unrestricted non-commercial use    */
X
X#include "xscheme.h"
X
X/* external variables */
Xextern LVAL true;
X
X/* external routines */
Xextern double atof();
Xextern ITYPE;
X
X/* forward declarations */
XLVAL read_list(),read_quote(),read_comma(),read_symbol();
XLVAL read_radix(),read_string(),read_special();
X
X/* xlread - read an expression */
Xint xlread(fptr,pval)
X  LVAL fptr,*pval;
X{
X    int ch;
X
X    /* check the next non-blank character */
X    while ((ch = scan(fptr)) != EOF)
X    switch (ch) {
X    case '(':
X        *pval = read_list(fptr);
X        return (TRUE);
X    case ')':
X        xlfail("misplaced right paren");
X    case '\'':
X        *pval = read_quote(fptr,"QUOTE");
X        return (TRUE);
X    case '`':
X        *pval = read_quote(fptr,"QUASIQUOTE");
X        return (TRUE);
X    case ',':
X        *pval = read_comma(fptr);
X        return (TRUE);
X    case '"':
X        *pval = read_string(fptr);
X        return (TRUE);
X    case '#':
X        *pval = read_special(fptr);
X        return (TRUE);
X    case ';':
X            read_comment(fptr);
X            break;
X    default:
X        xlungetc(fptr,ch);
X        *pval = read_symbol(fptr);
X        return (TRUE);
X    }
X    return (FALSE);
X}
X
X/* read_list - read a list */
XLOCAL LVAL read_list(fptr)
X  LVAL fptr;
X{
X    LVAL last,val;
X    int ch;
X
X    cpush(NIL); last = NIL;
X    while ((ch = scan(fptr)) != EOF)
X    switch (ch) {
X    case ';':
X        read_comment(fptr);
X        break;
X    case ')':
X        return (pop());
X    default:
X        xlungetc(fptr,ch);
X        if (!xlread(fptr,&val))
X        xlfail("unexpected EOF");
X        if (val == xlenter(".")) {
X        if (last == NIL)
X            xlfail("misplaced dot");
X        read_cdr(fptr,last);
X        return (pop());
X        }
X        else {
X        val = cons(val,NIL);
X        if (last) rplacd(last,val);
X        else settop(val);
X        last = val;
X        }
X        break;
X    }
X    xlfail("unexpected EOF");
X}
X
X/* read_cdr - read the cdr of a dotted pair */
XLOCAL read_cdr(fptr,last)
X  LVAL fptr,last;
X{
X    LVAL val;
X    int ch;
X
X    /* read the cdr expression */
X    if (!xlread(fptr,&val))
X    xlfail("unexpected EOF");
X    rplacd(last,val);
X
X    /* check for the close paren */
X    while ((ch = scan(fptr)) == ';')
X    read_comment(fptr);
X    if (ch != ')')
X    xlfail("missing right paren");
X}
X
X/* read_comment - read a comment (to end of line) */
XLOCAL read_comment(fptr)
X  LVAL fptr;
X{
X    int ch;
X    while ((ch = xlgetc(fptr)) != EOF && ch != '\n')
X    ;
X    if (ch != EOF) xlungetc(fptr,ch);
X}
X
X/* read_vector - read a vector */
XLOCAL LVAL read_vector(fptr)
X  LVAL fptr;
X{
X    int len=0,ch,i;
X    LVAL last,val;
X
X    cpush(NIL); last = NIL;
X    while ((ch = scan(fptr)) != EOF)
X    switch (ch) {
X    case ';':
X        read_comment(fptr);
X        break;
X    case ')':
X        val = newvector(len);
X        for (last = pop(), i = 0; i < len; ++i, last = cdr(last))
X        setelement(val,i,car(last));
X        return (val);
X    default:
X        xlungetc(fptr,ch);
X        if (!xlread(fptr,&val))
X        xlfail("unexpected EOF");
X        val = cons(val,NIL);
X        if (last) rplacd(last,val);
X        else settop(val);
X        last = val;
X        ++len;
X        break;
X    }
X    xlfail("unexpected EOF");
X}
X
X/* read_comma - read a unquote or unquote-splicing expression */
XLOCAL LVAL read_comma(fptr)
X  LVAL fptr;
X{
X    int ch;
X    if ((ch = xlgetc(fptr)) == '@')
X    return (read_quote(fptr,"UNQUOTE-SPLICING"));
X    else {
X    xlungetc(fptr,ch);
X    return (read_quote(fptr,"UNQUOTE"));
X    }
X}
X
X/* read_quote - parse the tail of a quoted expression */
XLOCAL LVAL read_quote(fptr,sym)
X  LVAL fptr; char *sym;
X{
X    LVAL val;
X    if (!xlread(fptr,&val))
X    xlfail("unexpected EOF");
X    cpush(cons(val,NIL));
X    settop(cons(xlenter(sym),top()));
X    return (pop());
X}
X
X/* read_symbol - parse a symbol name (or a number) */
XLOCAL LVAL read_symbol(fptr)
X  LVAL fptr;
X{
X    char buf[STRMAX+1];
X    LVAL val;
X    if (!getsymbol(fptr,buf))
X    xlfail("expecting symbol name");
X    return (isnumber(buf,&val) ? val : xlenter(buf));
X}
X
X/* read_string - parse a string */
XLOCAL LVAL read_string(fptr)
X  LVAL fptr;
X{
X    char buf[STRMAX+1];
X    int ch,i;
X
X    /* get symbol name */
X    for (i = 0; (ch = checkeof(fptr)) != '"'; ) {
X    if (ch == '\\')
X        ch = checkeof(fptr);
X    if (i < STRMAX)
X        buf[i++] = ch;
X    }
X    buf[i] = '\0';
X
X    /* return a string */
X    return (cvstring(buf));
X}
X
X/* read_special - parse an atom starting with '#' */
XLOCAL LVAL read_special(fptr)
X  LVAL fptr;
X{
X    char buf[STRMAX+1],buf2[STRMAX+3];
X    int ch;
X    switch (ch = checkeof(fptr)) {
X    case '!':
X    if (getsymbol(fptr,buf)) {
X        if (strcmp(buf,"TRUE") == 0)
X        return (true);
X        else if (strcmp(buf,"FALSE") == 0)
X        return (NIL);
X        else if (strcmp(buf,"NULL") == 0)
X        return (NIL);
X        else {
X        sprintf(buf2,"#!%s",buf);
X        return (xlenter(buf2));
X        }
X    }
X    else
X        xlfail("expecting symbol after '#!'");
X    break;
X    case '\\':
X    ch = checkeof(fptr);    /* get the next character */
X    xlungetc(fptr,ch);    /* but allow getsymbol to get it also */
X    if (getsymbol(fptr,buf)) {
X        if (strcmp(buf,"NEWLINE") == 0)
X        ch = '\n';
X        else if (strcmp(buf,"SPACE") == 0)
X        ch = ' ';
X        else if (strlen(buf) > 1)
X        xlerror("unexpected symbol after '#\\'",cvstring(buf));
X    }
X    else            /* wasn't a symbol, get the character */
X        ch = checkeof(fptr);
X    return (cvchar(ch));
X    case '(':
X    return (read_vector(fptr));
X    case 'b':
X    case 'B':
X    return (read_radix(fptr,2));
X    case 'o':
X    case 'O':
X    return (read_radix(fptr,8));
X    case 'd':
X    case 'D':
X    return (read_radix(fptr,10));
X    case 'x':
X    case 'X':
X        return (read_radix(fptr,16));
X    default:
X    xlungetc(fptr,ch);
X    if (getsymbol(fptr,buf)) {
X        if (strcmp(buf,"T") == 0)
X        return (true);
X        else if (strcmp(buf,"F") == 0)
X        return (NIL);
X        else
X        xlerror("unexpected symbol after '#'",cvstring(buf));
X    }
X    else
X        xlerror("unexpected character after '#'",cvchar(xlgetc(fptr)));
X    break;
X    }
X}
X
X/* read_radix - read a number in a specified radix */
XLOCAL LVAL read_radix(fptr,radix)
X  LVAL fptr; int radix;
X{
X    FIXTYPE val;
X    int ch;
X
X    /* get symbol name */
X    for (val = (FIXTYPE)0; (ch = xlgetc(fptr)) != EOF && issym(ch); ) {
X        if (islower(ch)) ch = toupper(ch);
X    if (!isradixdigit(ch,radix))
X        xlerror("invalid digit",cvchar(ch));
X        val = val * radix + getdigit(ch);
X    }
X
X    /* save the break character */
X    xlungetc(fptr,ch);
X
X    /* return the number */
X    return (cvfixnum(val));
X}
X
X/* isradixdigit - check to see if a character is a digit in a radix */
XLOCAL int isradixdigit(ch,radix)
X  int ch,radix;
X{
X    switch (radix) {
X    case 2:    return (ch >= '0' && ch <= '1');
X    case 8:    return (ch >= '0' && ch <= '7');
X    case 10:    return (ch >= '0' && ch <= '9');
X    case 16:    return ((ch >= '0' && ch <= '9')
X                     || (ch >= 'A' && ch <= 'F'));
X    }
X}
X
X/* getdigit - convert an ascii code to a digit */
XLOCAL int getdigit(ch)
X  int ch;
X{
X    return (ch <= '9' ? ch - '0' : ch - 'A' + 10);
X}
X
X/* getsymbol - get a symbol name */
XLOCAL int getsymbol(fptr,buf)
X  LVAL fptr; char *buf;
X{
X    int ch,i;
X
X    /* get symbol name */
X    for (i = 0; (ch = xlgetc(fptr)) != EOF && issym(ch); )
X    if (i < STRMAX)
X        buf[i++] = (islower(ch) ? toupper(ch) : ch);
X    buf[i] = '\0';
X
X    /* save the break character */
X    xlungetc(fptr,ch);
X    return (buf[0] != '\0');
X}
X
X/* isnumber - check if this string is a number */
XLOCAL int isnumber(str,pval)
X  char *str; LVAL *pval;
X{
X    int dl,dot,dr;
X    char *p;
X
X    /* initialize */
X    p = str; dl = dot = dr = 0;
X
X    /* check for a sign */
X    if (*p == '+' || *p == '-')
X    p++;
X
X    /* check for a string of digits */
X    while (isdigit(*p))
X    p++, dl++;
X
X    /* check for a decimal point */
X    if (*p == '.') {
X    p++; dot = 1;
X    while (isdigit(*p))
X        p++, dr++;
X    }
X
X    /* check for an exponent */
X    if ((dl || dr) && *p == 'E') {
X    p++; dot = 1;
X
X    /* check for a sign */
X    if (*p == '+' || *p == '-')
X        p++;
X
X    /* check for a string of digits */
X    while (isdigit(*p))
X        p++, dr++;
X    }
X
X    /* make sure there was at least one digit and this is the end */
X    if ((dl == 0 && dr == 0) || *p)
X    return (FALSE);
X
X    /* convert the string to an integer and return successfully */
X    if (pval) {
X    if (*str == '+') ++str;
X    if (str[strlen(str)-1] == '.') str[strlen(str)-1] = 0;
X    *pval = (dot ? cvflonum(atof(str)) : cvfixnum(ICNV(str)));
X    }
X    return (TRUE);
X}
X
X/* scan - scan for the first non-blank character */
XLOCAL int scan(fptr)
X  LVAL fptr;
X{
X    int ch;
X
X    /* look for a non-blank character */
X    while ((ch = xlgetc(fptr)) != EOF && isspace(ch))
X    ;
X
X    /* return the character */
X    return (ch);
X}
X
X/* checkeof - get a character and check for end of file */
XLOCAL int checkeof(fptr)
X  LVAL fptr;
X{
X    int ch;
X    if ((ch = xlgetc(fptr)) == EOF)
X    xlfail("unexpected EOF");
X    return (ch);
X}
X
X/* issym - is this a symbol character? */
XLOCAL int issym(ch)
X  int ch;
X{
X    register char *p;
X    if (!isspace(ch)) {
X    for (p = "()';"; *p != '\0'; )
X        if (*p++ == ch)
X        return (FALSE);
X    return (TRUE);
X    }
X    return (FALSE);
X}
END_OF_FILE
if test 9004 -ne `wc -c <'Src/xsread.c'`; then
    echo shar: \"'Src/xsread.c'\" unpacked with wrong size!
fi
# end of 'Src/xsread.c'
fi
echo shar: End of archive 2 \(of 7\).
cp /dev/null ark2isdone
MISSING=""
for I in 1 2 3 4 5 6 7 ; do
    if test ! -f ark${I}isdone ; then
    MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 7 archives.
    rm -f ark[1-9]isdone
else
    echo You still need to unpack the following archives:
    echo "        " ${MISSING}
fi
##  End of shell archive.
exit 0
--
Mail submissions (sources or binaries) to <[e-mail]>.
Mail comments to the moderator at <[e-mail]>.
Post requests for sources, and general discussion to comp.sys.amiga.